Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/rtf/rtf.pas

Pascal/Delphi Source File | 1995-12-22 | 5.7 KB | 304 lines

{Attached is an attempt at a Pascal RTF reader, which I abandoned in
favor of C. The approach is to treat RTF as a language and write
a recursive descent parser for it. The C version works quite well.

The Pascal version may serve some simple purpose. It's yours to
use freely.}

program rtf;
uses crt;
const
  BUFSIZE     = 1024;
  BEGIN_CWORD = #$DC;
  BEGIN_GROUP = #$FB;
  END_GROUP   = #$FD;
  TOKENSET    : set of char = [BEGIN_CWORD,BEGIN_GROUP,END_GROUP];
var
  current_ch   : char;
  current_word : string[80];
  current_parm : integer;
  rtf_version  : integer;
  rtf_charset  : string[8];
  default_font : integer;
  margin       : integer;
  index        : integer;
  buffer       : array [1..BUFSIZE] of char;
  f            : file;
  tagfile      : text;

procedure item; forward;
procedure group; forward;

function o(ch: char) : char;
begin
  case ch of
    BEGIN_GROUP: o := '{';
    END_GROUP:   o := '}';
    BEGIN_CWORD: o := '\';
    else         o := ch;
  end;
end;

procedure getch;
var
  ch     : char;
  result : integer;

  function nextch : char;
  begin
    if index >= BUFSIZE then
    begin
      BlockRead(f, buffer, BUFSIZE, result);

      if result = 0 then
      begin
          writeln('Unexpected end of RTF file');
          halt;
      end;
      index := 0;
    end;

    inc(index);
    nextch := buffer[index];
  end;
begin
  ch := nextch;
  case ch of
    '\':
         begin
           ch := nextch;
           if ch in ['{','}','\'] then
             current_ch := ch
           else
           begin
             current_ch := BEGIN_CWORD;
             dec(index);
           end;
         end;
    '{': current_ch := BEGIN_GROUP;
    '}': current_ch := END_GROUP;
    else current_ch := ch;
  end;
end;

procedure accept(expected: char; echo: boolean);
begin
  if expected <> current_ch then
  begin
    writeln('SYNTAX: expected ',o(expected),' found ',o(current_ch));
  end
  else
  begin
    if echo and (current_ch in [' '..'~']+TOKENSET) then
      write(o(current_ch));
    getch;
  end;
end;

procedure accept_alpha(var alpha: string);
begin
  alpha := '';
  while current_ch in ['A'..'Z','a'..'z'] do
  begin
    alpha := alpha + current_ch;
    accept(current_ch, TRUE);
  end;
end;

procedure accept_num(var num: integer);
var
  value  : longint;
  signed : boolean;
begin
  if current_ch = '-' then
  begin
    signed := TRUE;
    accept('-',TRUE);
  end
  else
    signed := FALSE;

  value := 0;
  while current_ch in ['0'..'9'] do
  begin
    value := value*10 + ord(current_ch)-ord('0');
    accept(current_ch, TRUE);
  end;

  if value > 32767 then
  begin
    writeln('Integer overflow');
    value := 32767;
  end;

  if signed then
    num := -value
  else
    num := value;
end;

procedure control_word(var spelling: string; var parm: integer);
begin
  accept(BEGIN_CWORD,TRUE);
  accept_alpha(spelling);
  accept_num(parm);
  if current_ch = ' ' then
    accept(' ',TRUE);

  writeln(tagfile, spelling:10, parm:10);
end;

procedure indent(amount: integer);
var
  i : integer;
begin
  inc(margin, amount);

  writeln;
  for i:= 1 to margin do
    write(' ');
end;

procedure content;
begin
  indent(2);
  accept(BEGIN_GROUP,TRUE);
  indent(2);

  while current_ch <> END_GROUP do
  begin
    if current_ch = ';' then
    begin
      accept(current_ch, TRUE);
      indent(0);
    end
    else if current_ch = BEGIN_GROUP then
    begin
      content;
    end
    else if current_ch = BEGIN_CWORD then
    begin
      item;
    end
    else
      accept(current_ch, TRUE);
  end;

  indent(-2);
  accept(END_GROUP, TRUE);
  indent(-2);
end;

procedure item;
begin
  repeat
    if current_ch = BEGIN_GROUP then
    begin
      content;
    end
    else if current_ch = ';' then
    begin
      accept(';', TRUE);
      indent(0);
    end
    else
    begin
      while not (current_ch in [BEGIN_GROUP,END_GROUP,';']) do
        accept(current_ch, TRUE);
    end;
  until not (current_ch in [BEGIN_GROUP,';',BEGIN_CWORD]);
end;

procedure content1;
var
  alpha : string[80];
  parm  : integer;
begin
  while (current_ch <> END_GROUP) do
  begin
    case current_ch of
      BEGIN_GROUP:
                   group;
      BEGIN_CWORD:
                   control_word(alpha, parm);
      else
      begin
        {writeln('ERROR: unknown token: ',o(current_ch));}
        accept(current_ch, TRUE);
      end;
    end;
  end;
end;

procedure group;
begin
  indent(2);
  accept(BEGIN_GROUP, TRUE);
  indent(2);

  content1;

  indent(-2);
  accept(END_GROUP, TRUE);
  indent(-2);
end;

procedure version;
var
  alpha : string[80];
begin
  control_word(alpha, rtf_version);
  if alpha <> 'rtf' then
  begin
    writeln('Not an RTF file');
    halt;
  end;
end;

procedure character_set;
var
  parm : integer;
begin
  control_word(rtf_charset, parm);
end;

procedure rtfile;
begin
  accept(BEGIN_GROUP, TRUE);
  indent(2);

  version;
  character_set;

  content1;

  indent(-2);
  accept(END_GROUP, TRUE);
end;

begin
  ClrScr;
  margin := 0;

  assign(f, ParamStr(1));
  reset(f, 1);
  assign(output, '');
  rewrite(output);
  assign(tagfile, 'tagfile.dat');
  rewrite(tagfile);

  index  := BUFSIZE;
  getch;

  rtfile;
end.

+-------------------------------------------------+
|  John Day
|  Computer Science Innovations,Inc
|  Principal Engineer    PHONE: [phone] ext:410
|  Melbourne, Fl    FAX: [phone]
|              WWW:   http://www.csihq.com
|              EMAIL: [e-mail]
+--------------------------------------------------+